home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / pprint.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  49.7 KB  |  1,475 lines
  1. ;;; -*- Package: PRETTY-PRINT -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: pprint.lisp,v 1.13 92/12/08 20:01:11 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; CMU Common Lisp pretty printer.
  15. ;;; Written by William Lott.  Algorithm stolen from Richard Waters' XP.
  16. ;;;
  17. (in-package "PRETTY-PRINT" :nicknames '("PP"))
  18. (use-package "EXT")
  19. (use-package "KERNEL")
  20.  
  21. (export '(pretty-stream pretty-stream-p))
  22.  
  23. (in-package "LISP")
  24. (export '(pprint-logical-block pprint-pop pprint-exit-if-list-exhausted
  25.       pprint-newline pprint-indent pprint-tab
  26.       pprint-fill pprint-linear pprint-tabular
  27.       copy-pprint-dispatch pprint-dispatch set-pprint-dispatch))
  28. (in-package "PP")
  29.  
  30.  
  31. ;;;; Pretty streams
  32.  
  33. ;;; There are three different units for measuring character positions:
  34. ;;;  COLUMN - offset (if characters) from the start of the current line.
  35. ;;;  INDEX - index into the output buffer.
  36. ;;;  POSITION - some position in the stream of characters cycling through
  37. ;;;             the output buffer.
  38. ;;; 
  39. (deftype column ()
  40.   '(and fixnum unsigned-byte))
  41. ;;; The INDEX type is picked up from the kernel package.
  42. (deftype position ()
  43.   'fixnum)
  44.  
  45. (defconstant initial-buffer-size 128)
  46.  
  47. (defconstant default-line-length 80)
  48.  
  49. (defstruct (pretty-stream
  50.         (:include stream
  51.               (:out #'pretty-out)
  52.               (:sout #'pretty-sout)
  53.               (:misc #'pretty-misc))
  54.         (:constructor make-pretty-stream (target))
  55.         (:print-function %print-pretty-stream))
  56.   ;;
  57.   ;; Where the output is going to finally go.
  58.   ;; 
  59.   (target (required-argument) :type stream)
  60.   ;;
  61.   ;; Line length we should format to.  Cached here so we don't have to keep
  62.   ;; extracting it from the target stream.
  63.   (line-length (or *print-right-margin*
  64.            (lisp::line-length target)
  65.            default-line-length)
  66.            :type column)
  67.   ;;
  68.   ;; A simple string holding all the text that has been output but not yet
  69.   ;; printed.
  70.   (buffer (make-string initial-buffer-size) :type simple-string)
  71.   ;;
  72.   ;; The index into BUFFER where more text should be put.
  73.   (buffer-fill-pointer 0 :type index)
  74.   ;;
  75.   ;; Whenever we output stuff from the buffer, we shift the remaining noise
  76.   ;; over.  This makes it difficult to keep references to locations in
  77.   ;; the buffer.  Therefore, we have to keep track of the total amount of
  78.   ;; stuff that has been shifted out of the buffer.
  79.   (buffer-offset 0 :type position)
  80.   ;;
  81.   ;; The column the first character in the buffer will appear in.  Normally
  82.   ;; zero, but if we end up with a very long line with no breaks in it we
  83.   ;; might have to output part of it.  Then this will no longer be zero.
  84.   (buffer-start-column (or (lisp::charpos target) 0) :type column)
  85.   ;;
  86.   ;; The line number we are currently on.  Used for *print-lines* abrevs and
  87.   ;; to tell when sections have been split across multiple lines.
  88.   (line-number 0 :type index)
  89.   ;;
  90.   ;; Stack of logical blocks in effect at the buffer start.
  91.   (blocks (list (make-logical-block)) :type list)
  92.   ;;
  93.   ;; Buffer holding the per-line prefix active at the buffer start.
  94.   ;; Indentation is included in this.  The length of this is stored
  95.   ;; in the logical block stack.
  96.   (prefix (make-string initial-buffer-size) :type simple-string)
  97.   ;;
  98.   ;; Buffer holding the total remaining suffix active at the buffer start.
  99.   ;; The characters are right-justified in the buffer to make it easier
  100.   ;; to output the buffer.  The length is stored in the logical block
  101.   ;; stack.
  102.   (suffix (make-string initial-buffer-size) :type simple-string)
  103.   ;;
  104.   ;; Queue of pending operations.  When empty, HEAD=TAIL=NIL.  Otherwise,
  105.   ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
  106.   ;; cons.  Adding things to the queue is basically (setf (cdr head) (list
  107.   ;; new)) and removing them is basically (pop tail) [except that care must
  108.   ;; be taken to handle the empty queue case correctly.]
  109.   (queue-tail nil :type list)
  110.   (queue-head nil :type list)
  111.   ;;
  112.   ;; Block-start queue entries in effect at the queue head.
  113.   (pending-blocks nil :type list)
  114.   )
  115.  
  116. (defun %print-pretty-stream (pstream stream depth)
  117.   (declare (ignore depth))
  118.   #+nil
  119.   (print-unreadable-object (pstream stream :type t :identity t))
  120.   (format stream "#<pretty stream {~8,'0X}>"
  121.       (kernel:get-lisp-obj-address pstream)))
  122.  
  123.  
  124. (declaim (inline index-position position-index position-column))
  125. (defun index-position (index stream)
  126.   (declare (type index index) (type pretty-stream stream)
  127.        (values position))
  128.   (+ index (pretty-stream-buffer-offset stream)))
  129. (defun position-index (position stream)
  130.   (declare (type position position) (type pretty-stream stream)
  131.        (values index))
  132.   (- position (pretty-stream-buffer-offset stream)))
  133. (defun position-column (position stream)
  134.   (declare (type position position) (type pretty-stream stream)
  135.        (values position))
  136.   (index-column (position-index position stream) stream))
  137.  
  138.  
  139. ;;;; Stream interface routines.
  140.  
  141. (defun pretty-out (stream char)
  142.   (declare (type pretty-stream stream)
  143.        (type base-character char))
  144.   (cond ((char= char #\newline)
  145.      (enqueue-newline stream :literal))
  146.     (t
  147.      (assure-space-in-buffer stream 1)
  148.      (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream)))
  149.        (setf (schar (pretty-stream-buffer stream) fill-pointer) char)
  150.        (setf (pretty-stream-buffer-fill-pointer stream)
  151.          (1+ fill-pointer))))))
  152.  
  153. (defun pretty-sout (stream string start end)
  154.   (declare (type pretty-stream stream)
  155.        (type simple-string string)
  156.        (type index start)
  157.        (type (or index null) end))
  158.   (let ((end (or end (length string))))
  159.     (unless (= start end)
  160.       (let ((newline (position #\newline string :start start :end end)))
  161.     (cond
  162.      (newline
  163.       (pretty-sout stream string start newline)
  164.       (enqueue-newline stream :literal)
  165.       (pretty-sout stream string (1+ newline) end))
  166.      (t
  167.       (let ((chars (- end start)))
  168.         (loop
  169.           (let* ((available (assure-space-in-buffer stream chars))
  170.              (count (min available chars))
  171.              (fill-pointer (pretty-stream-buffer-fill-pointer stream))
  172.              (new-fill-ptr (+ fill-pointer count)))
  173.         (replace (pretty-stream-buffer stream)
  174.              string
  175.              :start1 fill-pointer :end1 new-fill-ptr
  176.              :start2 start)
  177.         (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
  178.         (decf chars count)
  179.         (when (zerop count)
  180.           (return))
  181.         (incf start count))))))))))
  182.  
  183. (defun pretty-misc (stream op &optional arg1 arg2)
  184.   (declare (ignore stream op arg1 arg2)))
  185.  
  186.  
  187.  
  188. ;;;; Logical blocks.
  189.  
  190. (defstruct logical-block
  191.   ;;
  192.   ;; The column this logical block started in.
  193.   (start-column 0 :type column)
  194.   ;;
  195.   ;; The column the current section started in.
  196.   (section-column 0 :type column)
  197.   ;;
  198.   ;; The length of the per-line prefix.  We can't move the indentation
  199.   ;; left of this.
  200.   (per-line-prefix-end 0 :type index)
  201.   ;;
  202.   ;; The overall length of the prefix, including any indentation.
  203.   (prefix-length 0 :type index)
  204.   ;;
  205.   ;; The overall length of the suffix.
  206.   (suffix-length 0 :type index)
  207.   ;; 
  208.   ;; The line number 
  209.   (section-start-line 0 :type index))
  210.  
  211. (defun really-start-logical-block (stream column prefix suffix)
  212.   (let* ((blocks (pretty-stream-blocks stream))
  213.      (prev-block (car blocks))
  214.      (per-line-end (logical-block-per-line-prefix-end prev-block))
  215.      (prefix-length (logical-block-prefix-length prev-block))
  216.      (suffix-length (logical-block-suffix-length prev-block))
  217.      (block (make-logical-block
  218.          :start-column column
  219.          :section-column column
  220.          :per-line-prefix-end per-line-end
  221.          :prefix-length prefix-length
  222.          :suffix-length suffix-length
  223.          :section-start-line (pretty-stream-line-number stream))))
  224.     (setf (pretty-stream-blocks stream) (cons block blocks))
  225.     (set-indentation stream column)
  226.     (when prefix
  227.       (setf (logical-block-per-line-prefix-end block) column)
  228.       (replace (pretty-stream-prefix stream) prefix
  229.            :start1 (- column (length prefix)) :end1 column))
  230.     (when suffix
  231.       (let* ((total-suffix (pretty-stream-suffix stream))
  232.          (total-suffix-len (length total-suffix))
  233.          (additional (length suffix))
  234.          (new-suffix-len (+ suffix-length additional)))
  235.     (when (> new-suffix-len total-suffix-len)
  236.       (let ((new-total-suffix-len
  237.          (max (* total-suffix-len 2)
  238.               (+ suffix-length
  239.              (floor (* additional 5) 4)))))
  240.         (setf total-suffix
  241.           (replace (make-string new-total-suffix-len) total-suffix
  242.                :start1 (- new-total-suffix-len suffix-length)
  243.                :start2 (- total-suffix-len suffix-length)))
  244.         (setf total-suffix-len new-total-suffix-len)
  245.         (setf (pretty-stream-suffix stream) total-suffix)))
  246.     (replace total-suffix suffix
  247.          :start1 (- total-suffix-len new-suffix-len)
  248.          :end1 (- total-suffix-len suffix-length))
  249.     (setf (logical-block-suffix-length block) new-suffix-len))))
  250.   nil)
  251.  
  252. (defun set-indentation (stream column)
  253.   (let* ((prefix (pretty-stream-prefix stream))
  254.      (prefix-len (length prefix))
  255.      (block (car (pretty-stream-blocks stream)))
  256.      (current (logical-block-prefix-length block))
  257.      (minimum (logical-block-per-line-prefix-end block))
  258.      (column (max minimum column)))
  259.     (when (> column prefix-len)
  260.       (setf prefix
  261.         (replace (make-string (max (* prefix-len 2)
  262.                        (+ prefix-len
  263.                       (floor (* (- column prefix-len) 5)
  264.                          4))))
  265.              prefix
  266.              :end1 current))
  267.       (setf (pretty-stream-prefix stream) prefix))
  268.     (when (> column current)
  269.       (fill prefix #\space :start current :end column))
  270.     (setf (logical-block-prefix-length block) column)))
  271.  
  272. (defun really-end-logical-block (stream)
  273.   (let* ((old (pop (pretty-stream-blocks stream)))
  274.      (old-indent (logical-block-prefix-length old))
  275.      (new (car (pretty-stream-blocks stream)))
  276.      (new-indent (logical-block-prefix-length new)))
  277.     (when (> new-indent old-indent)
  278.       (fill (pretty-stream-prefix stream) #\space
  279.         :start old-indent :end new-indent)))
  280.   nil)
  281.  
  282.  
  283.  
  284. ;;;; The pending operation queue.
  285.  
  286. (defstruct queued-op
  287.   (position 0 :type position))
  288.  
  289. (defmacro enqueue (stream type &rest args)
  290.   (let ((constructor (intern (concatenate 'string
  291.                       "MAKE-"
  292.                       (symbol-name type)))))
  293.     (once-only ((stream stream)
  294.         (entry `(,constructor :position
  295.                       (index-position
  296.                        (pretty-stream-buffer-fill-pointer
  297.                     ,stream)
  298.                        ,stream)
  299.                       ,@args))
  300.         (op `(list ,entry))
  301.         (head `(pretty-stream-queue-head ,stream)))
  302.       `(progn
  303.      (if ,head
  304.          (setf (cdr ,head) ,op)
  305.          (setf (pretty-stream-queue-tail ,stream) ,op))
  306.      (setf (pretty-stream-queue-head ,stream) ,op)
  307.      ,entry))))
  308.  
  309. (defstruct (section-start
  310.         (:include queued-op))
  311.   (depth 0 :type index)
  312.   (section-end nil :type (or null newline block-end)))
  313.  
  314. (defstruct (newline
  315.         (:include section-start))
  316.   (kind (required-argument)
  317.     :type (member :linear :fill :miser :literal :mandatory)))
  318.  
  319. (defun enqueue-newline (stream kind)
  320.   (let* ((depth (length (pretty-stream-pending-blocks stream)))
  321.      (newline (enqueue stream newline :kind kind :depth depth)))
  322.     (dolist (entry (pretty-stream-queue-tail stream))
  323.       (when (and (not (eq newline entry))
  324.          (section-start-p entry)
  325.          (null (section-start-section-end entry))
  326.          (<= depth (section-start-depth entry)))
  327.     (setf (section-start-section-end entry) newline))))
  328.   (maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
  329.  
  330. (defstruct (indentation
  331.         (:include queued-op))
  332.   (kind (required-argument) :type (member :block :current))
  333.   (amount 0 :type fixnum))
  334.  
  335. (defun enqueue-indent (stream kind amount)
  336.   (enqueue stream indentation :kind kind :amount amount))
  337.  
  338. (defstruct (block-start
  339.         (:include section-start))
  340.   (block-end nil :type (or null block-end))
  341.   (prefix nil :type (or null simple-string))
  342.   (suffix nil :type (or null simple-string)))
  343.  
  344. (defun start-logical-block (stream prefix per-line-p suffix)
  345.   (when prefix
  346.     (pretty-sout stream prefix 0 (length prefix)))
  347.   (let* ((pending-blocks (pretty-stream-pending-blocks stream))
  348.      (start (enqueue stream block-start
  349.              :prefix (and per-line-p prefix)
  350.              :suffix suffix
  351.              :depth (length pending-blocks))))
  352.     (setf (pretty-stream-pending-blocks stream)
  353.       (cons start pending-blocks))))
  354.  
  355. (defstruct (block-end
  356.         (:include queued-op))
  357.   (suffix nil :type (or null simple-string)))
  358.  
  359. (defun end-logical-block (stream)
  360.   (let* ((start (pop (pretty-stream-pending-blocks stream)))
  361.      (suffix (block-start-suffix start))
  362.      (end (enqueue stream block-end :suffix suffix)))
  363.     (when suffix
  364.       (pretty-sout stream suffix 0 (length suffix)))
  365.     (setf (block-start-block-end start) end)))
  366.  
  367. (defstruct (tab
  368.         (:include queued-op))
  369.   (sectionp nil :type (member t nil))
  370.   (relativep nil :type (member t nil))
  371.   (colnum 0 :type column)
  372.   (colinc 0 :type column))
  373.  
  374. (defun enqueue-tab (stream kind colnum colinc)
  375.   (multiple-value-bind
  376.       (sectionp relativep)
  377.       (ecase kind
  378.     (:line (values nil nil))
  379.     (:line-relative (values nil t))
  380.     (:section (values t nil))
  381.     (:section-relative (values t t)))
  382.     (enqueue stream tab :sectionp sectionp :relativep relativep
  383.          :colnum colnum :colinc colinc)))
  384.  
  385.  
  386. ;;;; Tab support.
  387.  
  388. (defun compute-tab-size (tab section-start column)
  389.   (let ((origin (if (tab-sectionp tab) section-start 0))
  390.     (colnum (tab-colnum tab))
  391.     (colinc (tab-colinc tab)))
  392.     (cond ((tab-relativep tab)
  393.        (unless (<= colinc 1)
  394.          (let ((newposn (+ column colnum)))
  395.            (let ((rem (rem newposn colinc)))
  396.          (unless (zerop rem)
  397.            (incf colnum (- colinc rem))))))
  398.        colnum)
  399.       ((<= column (+ colnum origin))
  400.        (- (+ colnum origin) column))
  401.       (t
  402.        (- colinc
  403.           (rem (- column origin) colinc))))))
  404.  
  405. (defun index-column (index stream)
  406.   (let ((column (pretty-stream-buffer-start-column stream))
  407.     (section-start (logical-block-section-column
  408.             (first (pretty-stream-blocks stream))))
  409.     (end-position (index-position index stream)))
  410.     (dolist (op (pretty-stream-queue-tail stream))
  411.       (when (>= (queued-op-position op) end-position)
  412.     (return))
  413.       (typecase op
  414.     (tab
  415.      (incf column
  416.            (compute-tab-size op
  417.                  section-start
  418.                  (+ column
  419.                     (position-index (tab-position op)
  420.                             stream)))))
  421.     ((or newline block-start)
  422.      (setf section-start
  423.            (+ column (position-index (queued-op-position op)
  424.                      stream))))))
  425.     (+ column index)))
  426.  
  427. (defun expand-tabs (stream through)
  428.   (let ((insertions nil)
  429.     (additional 0)
  430.     (column (pretty-stream-buffer-start-column stream))
  431.     (section-start (logical-block-section-column
  432.             (first (pretty-stream-blocks stream)))))
  433.     (dolist (op (pretty-stream-queue-tail stream))
  434.       (typecase op
  435.     (tab
  436.      (let* ((index (position-index (tab-position op) stream))
  437.         (tabsize (compute-tab-size op
  438.                        section-start
  439.                        (+ column index))))
  440.        (unless (zerop tabsize)
  441.          (push (cons index tabsize) insertions)
  442.          (incf additional tabsize)
  443.          (incf column tabsize))))
  444.     ((or newline block-start)
  445.      (setf section-start
  446.            (+ column (position-index (queued-op-position op) stream)))))
  447.       (when (eq op through)
  448.     (return)))
  449.     (when insertions
  450.       (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
  451.          (new-fill-ptr (+ fill-ptr additional))
  452.          (buffer (pretty-stream-buffer stream))
  453.          (new-buffer buffer)
  454.          (length (length buffer))
  455.          (end fill-ptr))
  456.     (when (> new-fill-ptr length)
  457.       (let ((new-length (max (* length 2)
  458.                  (+ fill-ptr
  459.                     (floor (* additional 5) 4)))))
  460.         (setf new-buffer (make-string new-length))
  461.         (setf (pretty-stream-buffer stream) new-buffer)))
  462.     (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
  463.     (decf (pretty-stream-buffer-offset stream) additional)
  464.     (dolist (insertion insertions)
  465.       (let* ((srcpos (car insertion))
  466.          (amount (cdr insertion))
  467.          (dstpos (+ srcpos additional)))
  468.         (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
  469.         (fill new-buffer #\space :start srcpos :end dstpos)
  470.         (decf additional amount)
  471.         (setf end srcpos)))
  472.     (unless (eq new-buffer buffer)
  473.       (replace new-buffer buffer :end1 end :end2 end))))))
  474.  
  475.  
  476. ;;;; Stuff to do the actual outputting.
  477.  
  478. (defun assure-space-in-buffer (stream want)
  479.   (declare (type pretty-stream stream)
  480.        (type index want))
  481.   (let* ((buffer (pretty-stream-buffer stream))
  482.      (length (length buffer))
  483.      (fill-ptr (pretty-stream-buffer-fill-pointer stream))
  484.      (available (- length fill-ptr)))
  485.     (cond ((plusp available)
  486.        available)
  487.       ((> fill-ptr (pretty-stream-line-length stream))
  488.        (unless (maybe-output stream nil)
  489.          (output-partial-line stream))
  490.        (assure-space-in-buffer stream want))
  491.       (t
  492.        (let* ((new-length (max (* length 2)
  493.                    (+ length
  494.                       (floor (* want 5) 4))))
  495.           (new-buffer (make-string new-length)))
  496.          (setf (pretty-stream-buffer stream) new-buffer)
  497.          (replace new-buffer buffer :end1 fill-ptr)
  498.          (- new-length fill-ptr))))))
  499.  
  500. (defun maybe-output (stream force-newlines-p)
  501.   (declare (type pretty-stream stream))
  502.   (let ((tail (pretty-stream-queue-tail stream))
  503.     (output-anything nil))
  504.     (loop
  505.       (unless tail
  506.     (setf (pretty-stream-queue-head stream) nil)
  507.     (return))
  508.       (let ((next (pop tail)))
  509.     (etypecase next
  510.       (newline
  511.        (when (ecase (newline-kind next)
  512.            ((:literal :mandatory :linear) t)
  513.            (:miser (misering-p stream))
  514.            (:fill
  515.             (or (misering-p stream)
  516.             (> (pretty-stream-line-number stream)
  517.                (logical-block-section-start-line
  518.                 (first (pretty-stream-blocks stream))))
  519.             (ecase (fits-on-line-p stream
  520.                            (newline-section-end next)
  521.                            force-newlines-p)
  522.               ((t) nil)
  523.               ((nil) t)
  524.               (:dont-know
  525.                (return))))))
  526.          (setf output-anything t)
  527.          (output-line stream next)))
  528.       (indentation
  529.        (unless (misering-p stream)
  530.          (set-indentation stream
  531.                   (+ (ecase (indentation-kind next)
  532.                    (:block
  533.                     (logical-block-start-column
  534.                      (car (pretty-stream-blocks stream))))
  535.                    (:current
  536.                     (position-column
  537.                      (indentation-position next)
  538.                      stream)))
  539.                  (indentation-amount next)))))
  540.       (block-start
  541.        (ecase (fits-on-line-p stream (block-start-section-end next)
  542.                   force-newlines-p)
  543.          ((t)
  544.           ;; Just nuke the whole logical block and make it look like one
  545.           ;; nice long literal.
  546.           (let ((end (block-start-block-end next)))
  547.         (expand-tabs stream end)
  548.         (setf tail (cdr (member end tail)))))
  549.          ((nil)
  550.           (really-start-logical-block
  551.            stream
  552.            (position-column (block-start-position next) stream)
  553.            (block-start-prefix next)
  554.            (block-start-suffix next)))
  555.          (:dont-know
  556.           (return))))
  557.       (block-end
  558.        (really-end-logical-block stream))
  559.       (tab
  560.        (expand-tabs stream next))))
  561.       (setf (pretty-stream-queue-tail stream) tail))
  562.     output-anything))
  563.  
  564. (defun misering-p (stream)
  565.   (declare (type pretty-stream stream))
  566.   (and *print-miser-width*
  567.        (<= (- (pretty-stream-line-length stream)
  568.           (logical-block-start-column (car (pretty-stream-blocks stream))))
  569.        *print-miser-width*)))
  570.  
  571. (defun fits-on-line-p (stream until force-newlines-p)
  572.   (let ((available (pretty-stream-line-length stream)))
  573.     (when (and *print-lines*
  574.            (= *print-lines* (pretty-stream-line-number stream)))
  575.       (decf available 3) ; for the `` ..''
  576.       (decf available (logical-block-suffix-length
  577.                (car (pretty-stream-blocks stream)))))
  578.     (cond (until
  579.        (<= (position-column (queued-op-position until) stream) available))
  580.       (force-newlines-p nil)
  581.       ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
  582.           available)
  583.        nil)
  584.       (t
  585.        :dont-know))))
  586.  
  587. (defun output-line (stream until)
  588.   (declare (type pretty-stream stream)
  589.        (type newline until))
  590.   (let* ((target (pretty-stream-target stream))
  591.      (buffer (pretty-stream-buffer stream))
  592.      (kind (newline-kind until))
  593.      (literal-p (eq kind :literal))
  594.      (amount-to-consume (position-index (newline-position until) stream))
  595.      (amount-to-print
  596.       (if literal-p
  597.           amount-to-consume
  598.           (let ((last-non-blank
  599.              (position #\space buffer :end amount-to-consume
  600.                    :from-end t :test #'char/=)))
  601.         (if last-non-blank
  602.             (1+ last-non-blank)
  603.             0)))))
  604.     (write-string buffer target :end amount-to-print)
  605.     (let ((line-number (pretty-stream-line-number stream)))
  606.       (incf line-number)
  607.       (when (and *print-lines* (>= line-number *print-lines*))
  608.     (write-string " .." target)
  609.     (let ((suffix-length (logical-block-suffix-length
  610.                   (car (pretty-stream-blocks stream)))))
  611.       (unless (zerop suffix-length)
  612.         (let* ((suffix (pretty-stream-suffix stream))
  613.            (len (length suffix)))
  614.           (write-string suffix target
  615.                 :start (- len suffix-length)
  616.                 :end len))))
  617.     (throw 'line-limit-abbreviation-happened t))
  618.       (setf (pretty-stream-line-number stream) line-number)
  619.       (write-char #\newline target)
  620.       (setf (pretty-stream-buffer-start-column stream) 0)
  621.       (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
  622.          (block (first (pretty-stream-blocks stream)))
  623.          (prefix-len
  624.           (if literal-p
  625.           (logical-block-per-line-prefix-end block)
  626.           (logical-block-prefix-length block)))
  627.          (shift (- amount-to-consume prefix-len))
  628.          (new-fill-ptr (- fill-ptr shift))
  629.          (new-buffer buffer)
  630.          (buffer-length (length buffer)))
  631.     (when (> new-fill-ptr buffer-length)
  632.       (setf new-buffer
  633.         (make-string (max (* buffer-length 2)
  634.                   (+ buffer-length
  635.                      (floor (* (- new-fill-ptr buffer-length)
  636.                            5)
  637.                         4)))))
  638.       (setf (pretty-stream-buffer stream) new-buffer))
  639.     (replace new-buffer buffer
  640.          :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
  641.     (replace new-buffer (pretty-stream-prefix stream)
  642.          :end1 prefix-len)
  643.     (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
  644.     (incf (pretty-stream-buffer-offset stream) shift)
  645.     (unless literal-p
  646.       (setf (logical-block-section-column block) prefix-len)
  647.       (setf (logical-block-section-start-line block) line-number))))))
  648.  
  649. (defun output-partial-line (stream)
  650.   (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
  651.      (tail (pretty-stream-queue-tail stream))
  652.      (count
  653.       (if tail
  654.           (position-index (queued-op-position (car tail)) stream)
  655.           fill-ptr))
  656.      (new-fill-ptr (- fill-ptr count))
  657.      (buffer (pretty-stream-buffer stream)))
  658.     (when (zerop count)
  659.       (error "Output-partial-line called when nothing can be output."))
  660.     (write-string buffer (pretty-stream-target stream)
  661.           :start 0 :end count)
  662.     (incf (pretty-stream-buffer-start-column stream) count)
  663.     (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
  664.     (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
  665.     (incf (pretty-stream-buffer-offset stream) count)))
  666.  
  667. (defun force-pretty-output (stream)
  668.   (maybe-output stream nil)
  669.   (expand-tabs stream nil)
  670.   (write-string (pretty-stream-buffer stream)
  671.         (pretty-stream-target stream)
  672.         :end (pretty-stream-buffer-fill-pointer stream)))
  673.  
  674.  
  675. ;;;; Utilities.
  676.  
  677. ;;; WITH-PRETTY-STREAM -- internal.
  678. ;;;
  679. (defmacro with-pretty-stream
  680.       ((stream-var &optional (stream-expression stream-var)) &body body)
  681.   (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
  682.     `(flet ((,flet-name (,stream-var)
  683.           ,@body))
  684.        (let ((stream ,stream-expression))
  685.      (if (pretty-stream-p stream)
  686.          (,flet-name stream)
  687.          (catch 'line-limit-abbreviation-happened
  688.            (let ((stream (make-pretty-stream stream)))
  689.          (,flet-name stream)
  690.          (force-pretty-output stream)))))
  691.        nil)))
  692.  
  693.  
  694. ;;;; User interface to the pretty printer.
  695.  
  696. (defmacro pprint-logical-block
  697.       ((stream-symbol object &key prefix per-line-prefix suffix)
  698.        &body body)
  699.   "Group some output into a logical block.  STREAM-SYMBOL should be either a
  700.    stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*).  The printer
  701.    control variable *PRINT-LEVEL* is automatically handled."
  702.   (when (and prefix per-line-prefix)
  703.     (error "Cannot specify both a prefix and a per-line-perfix."))
  704.   (multiple-value-bind
  705.       (stream-var stream-expression)
  706.       (case stream-symbol
  707.     ((nil)
  708.      (values '*standard-output* '*standard-output*))
  709.     ((t)
  710.      (values '*terminal-io* '*terminal-io*))
  711.     (t
  712.      (values stream-symbol
  713.          (once-only ((stream stream-symbol))
  714.            `(case ,stream
  715.               ((nil) *standard-output*)
  716.               ((t) *terminal-io*)
  717.               (t ,stream))))))
  718.     (let* ((object-var (if object (gensym) nil))
  719.        (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
  720.        (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
  721.        (pp-pop-name (gensym "PPRINT-POP-"))
  722.        (body
  723.         `(descend-into (,stream-var)
  724.            (let ((,count-name 0))
  725.          (declare (type index ,count-name) (ignorable ,count-name))
  726.          (start-logical-block ,stream-var ,(or prefix per-line-prefix)
  727.                       ,(if per-line-prefix t nil) ,suffix)
  728.          (block ,block-name
  729.            (flet ((,pp-pop-name ()
  730.                 ,@(when object
  731.                 `((unless (listp ,object-var)
  732.                     (write-string ". " ,stream-var)
  733.                     (output-object ,object-var ,stream-var)
  734.                     (return-from ,block-name nil))))
  735.                 (when (eql ,count-name *print-length*)
  736.                   (write-string "..." ,stream-var)
  737.                   (return-from ,block-name nil))
  738.                 ,@(when object
  739.                 `((when (and ,object-var
  740.                          (plusp ,count-name)
  741.                          (check-for-circularity
  742.                           ,object-var))
  743.                     (write-string ". " ,stream-var)
  744.                     (output-object ,object-var ,stream-var)
  745.                     (return-from ,block-name nil))))
  746.                 (incf ,count-name)
  747.                 ,@(when object
  748.                 `((pop ,object-var)))))
  749.              (declare (ignorable #',pp-pop-name))
  750.              (macrolet ((pprint-pop ()
  751.                   '(,pp-pop-name))
  752.                 (pprint-exit-if-list-exhausted ()
  753.                   ,(if object
  754.                        `'(when (null ,object-var)
  755.                        (return-from ,block-name nil))
  756.                        `'(return-from ,block-name nil))))
  757.                ,@body)))
  758.          (end-logical-block ,stream-var)))))
  759.       (when object
  760.     (setf body
  761.           `(let ((,object-var ,object))
  762.          (if (listp ,object-var)
  763.              ,body
  764.              (output-object ,object-var ,stream-var)))))
  765.       `(with-pretty-stream (,stream-var ,stream-expression)
  766.      ,body))))
  767.  
  768. (defmacro pprint-exit-if-list-exhausted ()
  769.   "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
  770.    if it's list argument is exhausted.  Can only be used inside
  771.    PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
  772.    PPRINT-LOGICAL-BLOCK is supplied."
  773.   (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
  774.       PPRINT-LOGICAL-BLOCK."))
  775.  
  776. (defmacro pprint-pop ()
  777.   "Return the next element from LIST argument to the closest enclosing
  778.    use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
  779.    and *PRINT-CIRCLE*.  Can only be used inside PPRINT-LOGICAL-BLOCK.
  780.    If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
  781.    is poped, but the *PRINT-LENGTH* testing still happens."
  782.   (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
  783.   
  784. (defun pprint-newline (kind &optional stream)
  785.   "Output a conditional newline to STREAM (which defaults to
  786.    *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
  787.    nothing if not.  KIND can be one of:
  788.      :LINEAR - A line break is inserted if and only if the immediatly
  789.         containing section cannot be printed on one line.
  790.      :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
  791.         (See *PRINT-MISER-WIDTH*.)
  792.      :FILL - A line break is inserted if and only if either:
  793.        (a) the following section cannot be printed on the end of the
  794.            current line,
  795.        (b) the preceding section was not printed on a single line, or
  796.        (c) the immediately containing section cannot be printed on one
  797.            line and miser-style is in effect.
  798.      :MANDATORY - A line break is always inserted.
  799.    When a line break is inserted by any type of conditional newline, any
  800.    blanks that immediately precede the conditional newline are ommitted
  801.    from the output and indentation is introduced at the beginning of the
  802.    next line.  (See PPRINT-INDENT.)"
  803.   (declare (type (member :linear :miser :fill :mandatory) kind)
  804.        (type (or stream (member t nil)) stream)
  805.        (values null))
  806.   (let ((stream (case stream
  807.           ((t) *terminal-io*)
  808.           ((nil) *standard-output*)
  809.           (t stream))))
  810.     (when (pretty-stream-p stream)
  811.       (enqueue-newline stream kind)))
  812.   nil)
  813.  
  814. (defun pprint-indent (relative-to n &optional stream)
  815.   "Specify the indentation to use in the current logical block if STREAM
  816.    (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
  817.    and do nothing if not.  (See PPRINT-LOGICAL-BLOCK.)  N is the indention
  818.    to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
  819.      :BLOCK - Indent relative to the column the current logical block
  820.         started on.
  821.      :CURRENT - Indent relative to the current column.
  822.    The new indention value does not take effect until the following line
  823.    break."
  824.   (declare (type (member :block :current) relative-to)
  825.        (type integer n)
  826.        (type (or stream (member t nil)) stream)
  827.        (values null))
  828.   (let ((stream (case stream
  829.           ((t) *terminal-io*)
  830.           ((nil) *standard-output*)
  831.           (t stream))))
  832.     (when (pretty-stream-p stream)
  833.       (enqueue-indent stream relative-to n)))
  834.   nil)
  835.  
  836. (defun pprint-tab (kind colnum colinc &optional stream)
  837.   "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
  838.    stream, perform tabbing based on KIND, otherwise do nothing.  KIND can
  839.    be one of:
  840.      :LINE - Tab to column COLNUM.  If already past COLNUM tab to the next
  841.        multiple of COLINC.
  842.      :SECTION - Same as :LINE, but count from the start of the current
  843.        section, not the start of the line.
  844.      :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
  845.        COLINC.
  846.      :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
  847.        of the current section, not the start of the line."
  848.   (declare (type (member :line :section :line-relative :section-relative) kind)
  849.        (type unsigned-byte colnum colinc)
  850.        (type (or stream (member t nil)) stream)
  851.        (values null))
  852.   (let ((stream (case stream
  853.           ((t) *terminal-io*)
  854.           ((nil) *standard-output*)
  855.           (t stream))))
  856.     (when (pretty-stream-p stream)
  857.       (enqueue-tab stream kind colnum colinc)))
  858.   nil)
  859.  
  860. (defun pprint-fill (stream list &optional (colon? t) atsign?)
  861.   "Output LIST to STREAM putting :FILL conditional newlines between each
  862.    element.  If COLON? is NIL (defaults to T), then no parens are printed
  863.    around the output.  ATSIGN? is ignored (but allowed so that PPRINT-FILL
  864.    can be used with the ~/.../ format directive."
  865.   (declare (ignore atsign?))
  866.   (pprint-logical-block (stream list
  867.                 :prefix (if colon? "(")
  868.                 :suffix (if colon? ")"))
  869.     (pprint-exit-if-list-exhausted)
  870.     (loop
  871.       (output-object (pprint-pop) stream)
  872.       (pprint-exit-if-list-exhausted)
  873.       (write-char #\space stream)
  874.       (pprint-newline :fill stream))))
  875.  
  876. (defun pprint-linear (stream list &optional (colon? t) atsign?)
  877.   "Output LIST to STREAM putting :LINEAR conditional newlines between each
  878.    element.  If COLON? is NIL (defaults to T), then no parens are printed
  879.    around the output.  ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
  880.    can be used with the ~/.../ format directive."
  881.   (declare (ignore atsign?))
  882.   (pprint-logical-block (stream list
  883.                 :prefix (if colon? "(")
  884.                 :suffix (if colon? ")"))
  885.     (pprint-exit-if-list-exhausted)
  886.     (loop
  887.       (output-object (pprint-pop) stream)
  888.       (pprint-exit-if-list-exhausted)
  889.       (write-char #\space stream)
  890.       (pprint-newline :linear stream))))
  891.  
  892. (defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize)
  893.   "Output LIST to STREAM tabbing to the next column that is an even multiple
  894.    of TABSIZE (which defaults to 16) between each element.  :FILL style
  895.    conditional newlines are also output between each element.  If COLON? is
  896.    NIL (defaults to T), then no parens are printed around the output.
  897.    ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
  898.    the ~/.../ format directive."
  899.   (declare (ignore atsign?))
  900.   (pprint-logical-block (stream list
  901.                 :prefix (if colon? "(")
  902.                 :suffix (if colon? ")"))
  903.     (pprint-exit-if-list-exhausted)
  904.     (loop
  905.       (output-object (pprint-pop) stream)
  906.       (pprint-exit-if-list-exhausted)
  907.       (write-char #\space stream)
  908.       (pprint-tab :section-relative 0 (or tabsize 16) stream)
  909.       (pprint-newline :fill stream))))
  910.  
  911.  
  912. ;;;; Pprint-dispatch tables.
  913.  
  914. (defvar *initial-pprint-dispatch*)
  915. (defvar *building-initial-table* nil)
  916.  
  917. (defstruct (pprint-dispatch-entry
  918.         (:print-function %print-pprint-dispatch-entry))
  919.   ;;
  920.   ;; The type specifier for this entry.
  921.   (type (required-argument) :type t)
  922.   ;;
  923.   ;; A function to test to see if an object is of this time.  Pretty must
  924.   ;; just (lambda (obj) (typep object type)) except that we handle the
  925.   ;; CONS type specially so that (cons (member foo)) works.  We don't
  926.   ;; bother computing this for entries in the CONS hash table, because
  927.   ;; we don't need it.
  928.   (test-fn nil :type (or function null))
  929.   ;;
  930.   ;; The priority for this guy.
  931.   (priority 0 :type real)
  932.   ;;
  933.   ;; T iff one of the original entries.
  934.   (initial-p *building-initial-table* :type (member t nil))
  935.   ;;
  936.   ;; And the associated function.
  937.   (function (required-argument) :type function))
  938.  
  939. (defun %print-pprint-dispatch-entry (entry stream depth)
  940.   (declare (ignore depth))
  941.   (print-unreadable-object (entry stream :type t)
  942.     (format stream "Type=~S, priority=~S~@[ [Initial]~]"
  943.         (pprint-dispatch-entry-type entry)
  944.         (pprint-dispatch-entry-priority entry)
  945.         (pprint-dispatch-entry-initial-p entry))))
  946.  
  947. (defstruct (pprint-dispatch-table
  948.         (:print-function %print-pprint-dispatch-table))
  949.   ;;
  950.   ;; A list of all the entries (except for CONS entries below) in highest
  951.   ;; to lowest priority.
  952.   (entries nil :type list)
  953.   ;;
  954.   ;; A hash table mapping things to entries for type specifiers of the
  955.   ;; form (CONS (MEMBER <thing>)).  If the type specifier is of this form,
  956.   ;; we put it in this hash table instead of the regular entries table.
  957.   (cons-entries (make-hash-table :test #'eql)))
  958.  
  959. (defun %print-pprint-dispatch-table (table stream depth)
  960.   (declare (ignore depth))
  961.   (print-unreadable-object (table stream :type t :identity t)))
  962.  
  963. (defun cons-type-specifier-p (spec)
  964.   (and (consp spec)
  965.        (eq (car spec) 'cons)
  966.        (cdr spec)
  967.        (null (cddr spec))
  968.        (let ((car (cadr spec)))
  969.      (and (consp car)
  970.           (let ((carcar (car car)))
  971.         (or (eq carcar 'member)
  972.             (eq carcar 'eql)))
  973.           (cdr car)
  974.           (null (cddr car))))))
  975.  
  976. (defun entry< (e1 e2)
  977.   (declare (type pprint-dispatch-entry e1 e2))
  978.   (if (pprint-dispatch-entry-initial-p e1)
  979.       (if (pprint-dispatch-entry-initial-p e2)
  980.       (< (pprint-dispatch-entry-priority e1)
  981.          (pprint-dispatch-entry-priority e2))
  982.       t)
  983.       (if (pprint-dispatch-entry-initial-p e2)
  984.       nil
  985.       (< (pprint-dispatch-entry-priority e1)
  986.          (pprint-dispatch-entry-priority e2)))))
  987.  
  988. (defun compute-test-fn (type)
  989.   (labels ((compute-test-expr (type object)
  990.          (if (listp type)
  991.          (case (car type)
  992.            (cons
  993.             (destructuring-bind
  994.             (&optional (car nil car-p) (cdr nil cdr-p))
  995.             (cdr type)
  996.               `(and (consp ,object)
  997.                 ,@(when car-p
  998.                 `(,(compute-test-expr car `(car ,object))))
  999.                 ,@(when cdr-p
  1000.                 `(,(compute-test-expr cdr `(cdr ,object)))))))
  1001.            (not
  1002.             (destructuring-bind (type) (cdr type)
  1003.               `(not ,(compute-test-expr type object))))
  1004.            (and
  1005.             `(and ,@(mapcar #'(lambda (type)
  1006.                     (compute-test-expr type object))
  1007.                     (cdr type))))
  1008.            (or
  1009.             `(or ,@(mapcar #'(lambda (type)
  1010.                        (compute-test-expr type object))
  1011.                    (cdr type))))
  1012.            (t
  1013.             `(typep ,object ',type)))
  1014.          `(typep ,object ',type))))
  1015.     (compile nil `(lambda (object) ,(compute-test-expr type 'object)))))
  1016.  
  1017. (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
  1018.   (declare (type (or pprint-dispatch-table null) table))
  1019.   (let* ((orig (or table *initial-pprint-dispatch*))
  1020.      (new (make-pprint-dispatch-table
  1021.            :entries (copy-list (pprint-dispatch-table-entries orig))))
  1022.      (new-cons-entries (pprint-dispatch-table-cons-entries new)))
  1023.     (maphash #'(lambda (key value)
  1024.          (setf (gethash key new-cons-entries) value))
  1025.          (pprint-dispatch-table-cons-entries orig))
  1026.     new))
  1027.  
  1028. (defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
  1029.   (declare (type (or pprint-dispatch-table null) table))
  1030.   (let* ((table (or table *initial-pprint-dispatch*))
  1031.      (cons-entry
  1032.       (and (consp object)
  1033.            (gethash (car object)
  1034.             (pprint-dispatch-table-cons-entries table))))
  1035.      (entry
  1036.       (dolist (entry (pprint-dispatch-table-entries table) cons-entry)
  1037.         (when (and cons-entry
  1038.                (entry< entry cons-entry))
  1039.           (return cons-entry))
  1040.         (when (funcall (pprint-dispatch-entry-test-fn entry) object)
  1041.           (return entry)))))
  1042.     (if entry
  1043.     (values (pprint-dispatch-entry-function entry) t)
  1044.     (values #'(lambda (stream object)
  1045.             (output-ugly-object object stream))
  1046.         nil))))
  1047.  
  1048. (defun set-pprint-dispatch (type function &optional
  1049.                 (priority 0) (table *print-pprint-dispatch*))
  1050.   (declare (type (or null function) function)
  1051.        (type real priority)
  1052.        (type pprint-dispatch-table table))
  1053.   (if function
  1054.       (if (cons-type-specifier-p type)
  1055.       (setf (gethash (second (second type))
  1056.              (pprint-dispatch-table-cons-entries table))
  1057.         (make-pprint-dispatch-entry :type type :priority priority
  1058.                         :function function))
  1059.       (let ((list (delete type (pprint-dispatch-table-entries table)
  1060.                   :key #'pprint-dispatch-entry-type
  1061.                   :test #'equal))
  1062.         (entry (make-pprint-dispatch-entry
  1063.             :type type :test-fn (compute-test-fn type)
  1064.             :priority priority :function function)))
  1065.         (do ((prev nil next)
  1066.          (next list (cdr next)))
  1067.         ((null next)
  1068.          (if prev
  1069.              (setf (cdr prev) (list entry))
  1070.              (setf list (list entry))))
  1071.           (when (entry< (car next) entry)
  1072.         (if prev
  1073.             (setf (cdr prev) (cons entry next))
  1074.             (setf list (cons entry next)))
  1075.         (return)))
  1076.         (setf (pprint-dispatch-table-entries table) list)))
  1077.       (if (cons-type-specifier-p type)
  1078.       (remhash (second (second type))
  1079.            (pprint-dispatch-table-cons-entries table))
  1080.       (setf (pprint-dispatch-table-entries table)
  1081.         (delete type (pprint-dispatch-table-entries table)
  1082.             :key #'pprint-dispatch-entry-type
  1083.             :test #'equal))))
  1084.   nil)
  1085.  
  1086.  
  1087. ;;;; Standard pretty-printing routines.
  1088.  
  1089. (defun pprint-array (stream array)
  1090.   (cond ((or (and (null *print-array*) (null *print-readably*))
  1091.          (stringp array)
  1092.          (bit-vector-p array))
  1093.      (output-ugly-object array stream))
  1094.     ((and *print-readably* (not (eq (array-element-type array) 't)))
  1095.      (let ((*print-readably* nil))
  1096.        (error "~S cannot be printed readably.")))
  1097.     ((vectorp array)
  1098.      (pprint-vector stream array))
  1099.     (t
  1100.      (pprint-multi-dim-array stream array))))
  1101.  
  1102. (defun pprint-vector (stream vector)
  1103.   (pprint-logical-block (stream nil :prefix "#(" :suffix ")")
  1104.     (dotimes (i (length vector))
  1105.       (pprint-pop)
  1106.       (unless (zerop i)
  1107.     (write-char #\space stream)
  1108.     (pprint-newline :fill stream))
  1109.       (output-object (aref vector i) stream))))
  1110.  
  1111. (defun pprint-multi-dim-array (stream array)
  1112.   (funcall (formatter "#~DA") stream (array-rank array))
  1113.   (lisp::with-array-data ((data array) (start) (end))
  1114.     (declare (ignore end))
  1115.     (labels ((output-guts (stream index dimensions)
  1116.            (if (null dimensions)
  1117.            (output-object (aref data index) stream)
  1118.            (pprint-logical-block
  1119.                (stream nil :prefix "(" :suffix ")")
  1120.              (let ((dim (car dimensions)))
  1121.                (unless (zerop dim)
  1122.              (let* ((dims (cdr dimensions))
  1123.                 (index index)
  1124.                 (step (reduce #'* dims))
  1125.                 (count 0))
  1126.                (loop                
  1127.                  (pprint-pop)
  1128.                  (output-guts stream index dims)
  1129.                  (when (= (incf count) dim)
  1130.                    (return))
  1131.                  (write-char #\space stream)
  1132.                  (pprint-newline (if dims :linear :fill)
  1133.                          stream)
  1134.                  (incf index step)))))))))
  1135.       (output-guts stream start (array-dimensions array)))))
  1136.  
  1137. (defun pprint-lambda-list (stream lambda-list &rest noise)
  1138.   (declare (ignore noise))
  1139.   (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
  1140.     (let ((state :required)
  1141.       (first t))
  1142.       (loop
  1143.     (pprint-exit-if-list-exhausted)
  1144.     (unless first
  1145.       (write-char #\space stream))
  1146.     (let ((arg (pprint-pop)))
  1147.       (unless first
  1148.         (case arg
  1149.           (&optional
  1150.            (setf state :optional)
  1151.            (pprint-newline :linear stream))
  1152.           ((&rest &body)
  1153.            (setf state :required)
  1154.            (pprint-newline :linear stream))
  1155.           (&key
  1156.            (setf state :key)
  1157.            (pprint-newline :linear stream))
  1158.           (&aux
  1159.            (setf state :optional)
  1160.            (pprint-newline :linear stream))
  1161.           (t
  1162.            (pprint-newline :fill stream))))
  1163.       (ecase state
  1164.         (:required
  1165.          (pprint-lambda-list stream arg))
  1166.         ((:optional :key)
  1167.          (pprint-logical-block
  1168.          (stream arg :prefix "(" :suffix ")")
  1169.            (pprint-exit-if-list-exhausted)
  1170.            (if (eq state :key)
  1171.            (pprint-logical-block
  1172.                (stream (pprint-pop) :prefix "(" :suffix ")")
  1173.              (pprint-exit-if-list-exhausted)
  1174.              (output-object (pprint-pop) stream)
  1175.              (pprint-exit-if-list-exhausted)
  1176.              (write-char #\space stream)
  1177.              (pprint-newline :fill stream)
  1178.              (pprint-lambda-list stream (pprint-pop))
  1179.              (loop
  1180.                (pprint-exit-if-list-exhausted)
  1181.                (write-char #\space stream)
  1182.                (pprint-newline :fill stream)
  1183.                (output-object (pprint-pop) stream)))
  1184.            (pprint-lambda-list stream (pprint-pop)))
  1185.            (loop
  1186.          (pprint-exit-if-list-exhausted)
  1187.          (write-char #\space stream)
  1188.          (pprint-newline :linear stream)
  1189.          (output-object (pprint-pop) stream))))))
  1190.     (setf first nil)))))
  1191.  
  1192. (defun pprint-lambda (stream list &rest noise)
  1193.   (declare (ignore noise))
  1194.   (funcall (formatter
  1195.         "~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
  1196.        stream list))
  1197.  
  1198. (defun pprint-block (stream list &rest noise)
  1199.   (declare (ignore noise))
  1200.   (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list))
  1201.  
  1202. (defun pprint-flet (stream list &rest noise)
  1203.   (declare (ignore noise))
  1204.   (funcall (formatter
  1205.         "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
  1206.        stream
  1207.        list))
  1208.  
  1209. (defun pprint-let (stream list &rest noise)
  1210.   (declare (ignore noise))
  1211.   (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
  1212.        stream
  1213.        list))
  1214.  
  1215. (defun pprint-progn (stream list &rest noise)
  1216.   (declare (ignore noise))
  1217.   (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list))
  1218.  
  1219. (defun pprint-progv (stream list &rest noise)
  1220.   (declare (ignore noise))
  1221.   (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
  1222.        stream list))
  1223.  
  1224. (defun pprint-quote (stream list &rest noise)
  1225.   (declare (ignore noise))
  1226.   (if (and (consp list)
  1227.        (consp (cdr list))
  1228.        (null (cddr list)))
  1229.       (case (car list)
  1230.     (function
  1231.      (write-string "#'" stream)
  1232.      (output-object (cadr list) stream))
  1233.     (quote
  1234.      (write-char #\' stream)
  1235.      (output-object (cadr list) stream))
  1236.     (t
  1237.      (pprint-fill stream list)))
  1238.       (pprint-fill stream list)))
  1239.  
  1240. (defun pprint-setq (stream list &rest noise)
  1241.   (declare (ignore noise))
  1242.   (pprint-logical-block (stream list :prefix "(" :suffix ")")
  1243.     (pprint-exit-if-list-exhausted)
  1244.     (output-object (pprint-pop) stream)
  1245.     (pprint-exit-if-list-exhausted)
  1246.     (write-char #\space stream)
  1247.     (pprint-newline :miser stream)
  1248.     (if (> (length list) 3)
  1249.     (loop
  1250.       (pprint-indent :current 2 stream)
  1251.       (output-object (pprint-pop) stream)
  1252.       (pprint-exit-if-list-exhausted)
  1253.       (write-char #\space stream)
  1254.       (pprint-newline :linear stream)
  1255.       (pprint-indent :current -2 stream)
  1256.       (output-object (pprint-pop) stream)
  1257.       (pprint-exit-if-list-exhausted)
  1258.       (write-char #\space stream)
  1259.       (pprint-newline :linear stream))
  1260.     (progn
  1261.       (pprint-indent :current 0 stream)
  1262.       (output-object (pprint-pop) stream)
  1263.       (pprint-exit-if-list-exhausted)
  1264.       (write-char #\space stream)
  1265.       (pprint-newline :linear stream)
  1266.       (output-object (pprint-pop) stream)))))
  1267.       
  1268. (defmacro pprint-tagbody-guts (stream)
  1269.   `(loop
  1270.      (pprint-exit-if-list-exhausted)
  1271.      (write-char #\space ,stream)
  1272.      (let ((form-or-tag (pprint-pop)))
  1273.        (pprint-indent :block 
  1274.               (if (atom form-or-tag) 0 1)
  1275.               ,stream)
  1276.        (pprint-newline :linear ,stream)
  1277.        (output-object form-or-tag ,stream))))
  1278.  
  1279. (defun pprint-tagbody (stream list &rest noise)
  1280.   (declare (ignore noise))
  1281.   (pprint-logical-block (stream list :prefix "(" :suffix ")")
  1282.     (pprint-exit-if-list-exhausted)
  1283.     (output-object (pprint-pop) stream)
  1284.     (pprint-tagbody-guts stream)))
  1285.  
  1286. (defun pprint-case (stream list &rest noise)
  1287.   (declare (ignore noise))
  1288.   (funcall (formatter
  1289.         "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/PP:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
  1290.        stream
  1291.        list))
  1292.  
  1293. (defun pprint-defun (stream list &rest noise)
  1294.   (declare (ignore noise))
  1295.   (funcall (formatter
  1296.         "~:<~^~W~^ ~@_~:I~W~^ ~:_~/PP:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
  1297.        stream
  1298.        list))
  1299.  
  1300. (defun pprint-destructuring-bind (stream list &rest noise)
  1301.   (declare (ignore noise))
  1302.   (funcall (formatter
  1303.     "~:<~^~W~^~3I ~_~:/PP:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
  1304.        stream list))
  1305.  
  1306. (defun pprint-do (stream list &rest noise)
  1307.   (declare (ignore noise))
  1308.   (pprint-logical-block (stream list :prefix "(" :suffix ")")
  1309.     (pprint-exit-if-list-exhausted)
  1310.     (output-object (pprint-pop) stream)
  1311.     (pprint-exit-if-list-exhausted)
  1312.     (write-char #\space stream)
  1313.     (pprint-indent :current 0 stream)
  1314.     (funcall (formatter "~:<~@{~:<~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
  1315.          stream
  1316.          (pprint-pop))
  1317.     (pprint-exit-if-list-exhausted)
  1318.     (write-char #\space stream)
  1319.     (pprint-newline :linear stream)
  1320.     (pprint-linear stream (pprint-pop))
  1321.     (pprint-tagbody-guts stream)))
  1322.  
  1323. (defun pprint-dolist (stream list &rest noise)
  1324.   (declare (ignore noise))
  1325.   (pprint-logical-block (stream list :prefix "(" :suffix ")")
  1326.     (pprint-exit-if-list-exhausted)
  1327.     (output-object (pprint-pop) stream)
  1328.     (pprint-exit-if-list-exhausted)
  1329.     (pprint-indent :block 3 stream)
  1330.     (write-char #\space stream)
  1331.     (pprint-newline :fill stream)
  1332.     (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
  1333.          stream
  1334.          (pprint-pop))
  1335.     (pprint-tagbody-guts stream)))
  1336.  
  1337. (defun pprint-typecase (stream list &rest noise)
  1338.   (declare (ignore noise))
  1339.   (funcall (formatter
  1340.         "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
  1341.        stream
  1342.        list))
  1343.  
  1344. (defun pprint-prog (stream list &rest noise)
  1345.   (declare (ignore noise))
  1346.   (pprint-logical-block (stream list :prefix "(" :suffix ")")
  1347.     (pprint-exit-if-list-exhausted)
  1348.     (output-object (pprint-pop) stream)
  1349.     (pprint-exit-if-list-exhausted)
  1350.     (write-char #\space stream)
  1351.     (pprint-newline :miser stream)
  1352.     (pprint-fill stream (pprint-pop))
  1353.     (pprint-tagbody-guts stream)))
  1354.  
  1355. (defun pprint-function-call (stream list &rest noise)
  1356.   (declare (ignore noise))
  1357.   (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
  1358.        stream
  1359.        list))
  1360.  
  1361.  
  1362. ;;;; Interface seen by regular (ugly) printer and initialization routines.
  1363.  
  1364. ;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is
  1365. ;;; bound to T.
  1366. ;;;
  1367. (defun output-pretty-object (object stream)
  1368.   (with-pretty-stream (stream)
  1369.     (funcall (pprint-dispatch object) stream object)))
  1370.  
  1371. (defparameter magic-forms
  1372.   '((lambda pprint-lambda)
  1373.     ;; Special forms.
  1374.     (block pprint-block)
  1375.     (catch pprint-block)
  1376.     (compiler-let pprint-let)
  1377.     (eval-when pprint-block)
  1378.     (flet pprint-flet)
  1379.     (function pprint-quote)
  1380.     (generic-flet pprint-flet)
  1381.     (generic-labels pprint-flet)
  1382.     (labels pprint-flet)
  1383.     (let pprint-let)
  1384.     (let* pprint-let)
  1385.     (locally pprint-progn)
  1386.     (macrolet pprint-flet)
  1387.     (multiple-value-call pprint-block)
  1388.     (multiple-value-prog1 pprint-block)
  1389.     (progn pprint-progn)
  1390.     (progv pprint-progv)
  1391.     (quote pprint-quote)
  1392.     (return-from pprint-block)
  1393.     (setq pprint-setq)
  1394.     (symbol-macrolet pprint-let)
  1395.     (tagbody pprint-tagbody)
  1396.     (throw pprint-block)
  1397.     (unwind-protect pprint-block)
  1398.     (with-added-methods pprint-flet)
  1399.     
  1400.     ;; Macros.
  1401.     (case pprint-case)
  1402.     (ccase pprint-case)
  1403.     (ctypecase pprint-typecase)
  1404.     (defconstant pprint-block)
  1405.     (define-modify-macro pprint-defun)
  1406.     (define-setf-method pprint-defun)
  1407.     (defmacro pprint-defun)
  1408.     (defparameter pprint-block)
  1409.     (defsetf pprint-defun)
  1410.     (defstruct pprint-block)
  1411.     (deftype pprint-defun)
  1412.     (defun pprint-defun)
  1413.     (defvar pprint-block)
  1414.     (destructuring-bind pprint-destructuring-bind)
  1415.     (do pprint-do)
  1416.     (do* pprint-do)
  1417.     (do-all-symbols pprint-dolist)
  1418.     (do-external-symbols pprint-dolist)
  1419.     (do-symbols pprint-dolist)
  1420.     (dolist pprint-dolist)
  1421.     (dotimes pprint-dolist)
  1422.     (ecase pprint-case)
  1423.     (etypecase pprint-typecase)
  1424.     #+nil (handler-bind ...)
  1425.     #+nil (handler-case ...)
  1426.     #+nil (loop ...)
  1427.     (multiple-value-bind pprint-progv)
  1428.     (multiple-value-setq pprint-block)
  1429.     (pprint-logical-block pprint-block)
  1430.     (print-unreadable-object pprint-block)
  1431.     (prog pprint-prog)
  1432.     (prog* pprint-prog)
  1433.     (prog1 pprint-block)
  1434.     (prog2 pprint-progv)
  1435.     (psetf pprint-setq)
  1436.     (psetq pprint-setq)
  1437.     #+nil (restart-bind ...)
  1438.     #+nil (restart-case ...)
  1439.     (setf pprint-setq)
  1440.     (step pprint-progn)
  1441.     (time pprint-progn)
  1442.     (typecase pprint-typecase)
  1443.     (unless pprint-block)
  1444.     (when pprint-block)
  1445.     (with-compilation-unit pprint-block)
  1446.     #+nil (with-condition-restarts ...)
  1447.     (with-hash-table-iterator pprint-block)
  1448.     (with-input-from-string pprint-block)
  1449.     (with-open-file pprint-block)
  1450.     (with-open-stream pprint-block)
  1451.     (with-output-to-string pprint-block)
  1452.     (with-package-iterator pprint-block)
  1453.     (with-simple-restart pprint-block)
  1454.     (with-standard-io-syntax pprint-progn)))
  1455.  
  1456. (defun pprint-init ()
  1457.   (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
  1458.   (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
  1459.     (*building-initial-table* t))
  1460.     ;; Printers for regular types.
  1461.     (set-pprint-dispatch 'array #'pprint-array)
  1462.     (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
  1463.              #'pprint-function-call -1)
  1464.     (set-pprint-dispatch 'cons #'pprint-fill -2)
  1465.     ;; Cons cells with interesting things for the car.
  1466.     (dolist (magic-form magic-forms)
  1467.       (set-pprint-dispatch `(cons (eql ,(first magic-form)))
  1468.                (symbol-function (second magic-form))))
  1469.     ;; Other pretty-print init forms.
  1470.     (lisp::backq-pp-init))
  1471.  
  1472.   (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
  1473.   (setf *pretty-printer* #'output-pretty-object)
  1474.   (setf *print-pretty* t))
  1475.